{-
    pHaskell Translator v0.1 
    Copyright (C) 2009  Ruben Marcelo Caro 

    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}
module TemplatesTypes where
import List

data MetaType = MetaTypeInteger | MetaTypeBoolean |MetaArrow MetaType MetaType | MetaUserDef String | MetaTypeUnknown
					deriving (Eq,Show)

type MetaProgram   = [MetaFunction]
 
data MetaFunction   =  MetaFunction String [MetaTreeExp]  
						deriving (Eq,Show)

					
data MetaExp =		   MetaInteger String 
					  |MetaBoolean String 
              		  |MetaVariable String 
              		  |MetaTypeConstructor String [MetaExp]
              		  |MetaApp    MetaExp MetaExp
              		  |MetaIf     MetaExp MetaExp MetaExp
              		  |MetaIfOnly MetaExp MetaExp 
              		  |MetaSkip
						deriving (Eq,Show)
						
data MetaTreeExp = 	 MetaNode (MetaExp, MetaType) [MetaTreeExp]  --CONTIENE UNA LISTA DE SUBNODOS MetaTreeExp
					|MetaLeaft MetaExp MetaProgram --Metaprogram es definiciones locales
						deriving (Eq,Show)
						
--Contexto

data Parent = 	PMetaFunction      --Es el cuerpo inicial de una funcion
				| PMetaValue       --Es una valor final
				| PMetaLambda      --Es una exprecion envuelta en una lambda
				| PMetaApp         --Es una aplicacion izquierda
				| PMetaApp'        --Es una aplicacion derecha
				| PMetaPrograms    --no tiene ancestro 
				| PMetaPatternMatching  --Esta dentro de una especialicacion .. app_matching: ACA
				| PMetaEager       --Es una exprecion eager, que va como typedef y no como herencia.
					deriving (Eq,Show)


-- El contexto consta de la lista de los padres de donde provino la 
-- expresion, la lista de variables bindeadas, nombres que son constructores
type Context = ([Parent],[String], [String]) 



{- MetaTreeExp utils-}
metaTreeListMerge::[MetaTreeExp]->[MetaTreeExp]->[MetaTreeExp]
metaTreeListMerge ts ([])		= ts
metaTreeListMerge ts (t:ts')    =  metaTreeListMerge (metaTreeMerge ts t)  ts'


metaTreeMerge::[MetaTreeExp]->MetaTreeExp->[MetaTreeExp]
metaTreeMerge ts node@(MetaNode (e, t) ts'') = case  find (equalByExp e) ts of
													Nothing    -> node:ts    
													Just node  -> (MetaNode (e, t) (metaTreeListMerge (getNodesFromNode node) ts'')):ts'
																	where
																		ts' =  delete node ts
																		getNodesFromNode (MetaNode (_, _) nds) = nds 
metaTreeMerge ts leaft = leaft:ts

equalByExp::MetaExp->MetaTreeExp->Bool
equalByExp (MetaVariable _) (MetaNode (MetaVariable _ , t) ts') = True
equalByExp e (MetaNode (e', t) ts')                             = (e == e')
  

						 
	

{-test						 
dummyExp = MetaInteger "5"
dummyExp2 = MetaInteger "6"
dummyExp3 = MetaInteger "7"
dummyExpX = MetaVariable "x"
dummyExpY = MetaVariable "y"
dummyExpZ = MetaVariable "z"

leaft1 = MetaLeaft dummyExp3 []
leaft2 = MetaLeaft dummyExp2 []
tree1  = MetaNode (dummyExp, MetaTypeInteger) [leaft1] 
tree2  = MetaNode (dummyExp2, MetaTypeInteger) [leaft1]
tree3  = MetaNode (dummyExpX, MetaTypeInteger) [leaft1]

treeA1 = MetaNode (dummyExpY, MetaTypeInteger) [tree1]
treeA2 = MetaNode (dummyExpY, MetaTypeInteger) [tree3]

treeP1 = MetaNode (dummyExpX, MetaTypeInteger) [tree1, treeA2,tree3]
treeP2 = MetaNode (dummyExpX, MetaTypeInteger) [tree1, treeA1,tree2] 
-}


{- Context utils-}


--debuelve el padre
father ([],bnd, ctors)    = PMetaPrograms
father ((p:ps),bnd, ctors) = p

addParent p (ps,bnd, ctors) = (p:ps, bnd, ctors)
addBinded v (ps,bnd, ctors) = (ps, v:bnd, ctors)

addListBinded vs (ps,bnd, ctors) = (ps, vs++bnd, ctors)

hasAncestor ancestor (context, bnd, ctors) = (find (==ancestor) context) ==  Just ancestor 

isBinded var (context, bnd, ctors) =  (find (==var) bnd) ==  Just var


isTypeConstructor (_, _ , ctors) ctorName = elem ctorName ctors

isTypeConstructorVariable (_, _ , ctors) (MetaVariable varName) =  elem varName ctors
isTypeConstructorVariable _ _ = False


existTypeConstructorNode::Context->[MetaTreeExp]->Bool
existTypeConstructorNode cs ((MetaNode (_, MetaUserDef _) _):es) = True
existTypeConstructorNode cs (e:es) = existTypeConstructorNode cs es
existTypeConstructorNode cs []     = False

